perm filename COMBI.F4[PAX,LCS] blob
sn#502598 filedate 1981-03-11 generic text, type T, neo UTF8
C****** COMBINES ONE-LINE MS FILES INTO 1 FILE WITH UP TO 8 LINES.
C****** LOAD WITH MSSIO.FAI[NEW,LCS]
COMMON/STF/RSTFAC(0/7),RSTJ2 /POSI/STFF(0/7),JJ2,JPQ
COMMON/XRN/RN(3000)/PTR/KWDS(300)
COMMON /PX/KPN(450) /Q/Q(3500),JQ,JK,STF,KQ,STFAC,JP
INTEGER EXT1,EXT,EXT3
TYPE 1
TYPE 85
20 FORMAT(I)
1 FORMAT(' ALWAYS USE ONLY 5-LETTER NAMES.'/)
85 FORMAT(' TYPE TOP FILE NAME '$)
2 FORMAT(A5,A1,A5)
3 FORMAT(' HOW MANY FILES? '$)
CC3 FORMAT(' TYPE BOTTOM FILE NAME '$)
5 FORMAT(' TYPE OUTPUT FILE NAME '$)
ACCEPT 2,NAM1,K,EXT1
TYPE 3
CC ACCEPT 2,NAME,K,EXT
ACCEPT 20,K
IF(K.EQ.0)K=7
NAME=NAM1+(K-1)*2
IF(EXT1.EQ.' ')EXT1='MS'
EXT=EXT1
CC IF(EXT.EQ.' ')EXT=EXT1
89 TYPE 5
ACCEPT 2,NAM3,K,EXT3
REREAD 87,STFF
DO 86 K=0,4
IF(STFF(K).NE.' '.AND.STFF(K).NE.'.')GO TO 86
TYPE 1
GO TO 89
86 CONTINUE
87 FORMAT(8A1)
IF(EXT3.EQ.' ')EXT3=EXT1
IF(LOOKX(NAM3,EXT3).GE.0)GO TO 21
TYPE 88,NAM3,EXT3
ACCEPT 2,L
IF(L.NE.'Y')GO TO 89
88 FORMAT(' WRITE OVER FILE ',A5,'.',A3,'???? '$)
21 IF(LOOKX(NAME,EXT).LT.0)GO TO 22
NAME=NAME-2
C FIND LAST AVAILABLE NAME
GO TO 21
22 STFAC=0
STF=0
JQ=0
JK=0
CC FAC=0
KQ=0
4 CALL INMUS(NAME,EXT,RN,KWDS,RSTFAC)
C ABOVE REPLACES GETEXT AND EXTIN. NEW SAVE FORMAT
C*** 4 CALL GETEXT(NAME,EXT)
C LP IS START OF RN ARRAY THIS TIME
TYPE 7,NAME,EXT
7 FORMAT(1XA5,'.',A5)
C*** CALL EXTIN(RSTFAC,20)
C*** CALL EXTIN(KWDS,JJ2)
C*** CALL EXTIN(RN,JPQ)
CALL PUTIT
C PUT RN INTO Q ARRAY, ETC.
CC FAC=FAC+6.3
NAME=NAME-2
STF=STF+1
JK=JK-1
JQ=JQ-1
IF(NAME.GE.NAM1)GO TO 4
6 JJ2=JK+2
JPQ=JQ+1
STF=STFAC*STF
Q(JP+8)=STF
CALL PUTEXT(NAM3,EXT3)
CALL EXTOUT(RSTFAC,20)
C*** CALL EXTOUT(KPN,JJ2)
C ABOVE NOT NEEDED WITH NEW SAVE FORMAT.
CALL EXTOUT(Q,JPQ)
CALL FINEXT
JJ2=JJ2-2
STFAC=STF*2.54
TYPE 23,NAM3,EXT3,JJ2,JPQ,STF,STFAC
23 FORMAT(//1XA5,'.',A5,I5,' ITEMS,',I6,' WDS, C.',F5.2,' INCHES,'
1,F7.2,' CM.')
END
SUBROUTINE PUTIT
COMMON/STF/RSTFAC(0/7),RSTJ2 /POSI/STFF(0/7),JJ2,JPQ
COMMON/XRN/RN(3000)/PTR/KWDS(300)
COMMON /PX/KPN(450) /Q/Q(3500),JQ,JK,STF,KQ,STFAC,JP
DO 1 K=1,JJ2-1
JK=JK+1
J=KWDS(K)
RN(J+2)=STF
R=RN(J+1)
IF(R.NE.8)GO TO 5
RN(J+4)=(STF*STFAC*23.8-17.55*STF)/RN(J+5)
C ASSUMES THERE IS A SOMETHING IN P5 AND P8
IF(RN(J).GE.6)STFAC=RN(J+8)
RN(J+8)=0
IF(JQ.EQ.0)JP=J
C SAVE POINTER TO FIRST STAFF. PUT IN INCHES AT END
GO TO 1
5 IF(R.NE.2)GO TO 1
IF(RN(J+9).GE.0)GO TO 1
C ONLY CHANGE POSITION OF REST IF P9=-1
IF(RN(J).LT.7)GO TO 1
JJ=K+1
6 JJJ=KWDS(JJ)
IF(RN(JJJ+1).EQ.4)GO TO 7
C LOOK FOR BAR LINE
JJ=JJ+1
IF(JJ.LT.JJ2)GO TO 6
GO TO 1
7 RN(J+9)=RN(J+3)+(RN(JJJ+3)-RN(J+3))/2.0-4.0*RSTFAC(0)
1 KPN(JK)=J+KQ
KQ=KQ+KWDS(JJ2-1)-1
3 DO 2 K=1,JPQ
JQ=JQ+1
2 Q(JQ)=RN(K)
4 END